PsL Monthly 1993 December/PSL Monthly Shareware CD-ROM (December 1993).iso/prgmming/dos/pascal/arith2.com/ARITH_EN.PAS

Pascal/Delphi Source File | 1989-02-27 | 6.4 KB | 219 lines

UNIT arith_en;

        { ------------------------------------------------------------------

          This program and its associates implement in Turbo Pascal v5
          the aritmetic encoding/decoding algorithms presented in the papers

          "Arithmetic Coding for Data Compression"

                   by Ian     H. Witten
                      Radford M. Neal
                      John    G. Cleary

          pp 520 - 540 of June 1987 Communications of the ACM

          and

          "An Adaptive Dependency Source Model For Data Compression"

                   by David M. Abrahamson

          pp 77 - 83 of January 1989 Communications of the ACM

          ------------------------------------------------------------------

          Implemented by Ken Westerback : CompuServe 73547,3520

          version 1.0 released 89/02/19
          version 2.0 released 89/02/27

          These programs, units and associated documentation are released
          into the public domain to be used and abused as your whims
          dictate.

          Feel free to distribute/incorporate/improve as desired.

          >>>>> Use at your own risk! <<<<<

          Comments and suggestions welcome via CompuServe.

          ------------------------------------------------------------------
        }

INTERFACE uses dos;


procedure start_encoding ( f_name : pathstr; model : char );

procedure encode_symbol  ( symbol : integer );

function  done_encoding  : longint; { return # characters written }


IMPLEMENTATION uses arith_h, model_h;


procedure start_encoding ( f_name : pathstr; model : char );
          begin

          {I-}
          assign ( bits_file, f_name );
          rewrite ( bits_file, 1 );
          {I+}

          if ioresult <> 0 then
             begin
             writeln;
             writeln ( 'arith_en : error opening "', f_name, '"' );
             writeln;
             halt;
             end;

          if model in valid_models then
             blockwrite ( bits_file, model, 1 )
          else
             begin
             writeln;
             writeln ( 'arith_de : "', model, '" is not a valid model id' );
             writeln;
             halt;
             end;

          bits_to_go := bits_per_buffer; { totally empty buffer assumed }

          end;

procedure bit_plus_follow ( bit : boolean );

          var bits_to_shift : byte;

          begin

          buffer := buffer shr 1;

          if ( bit ) then buffer := buffer or high_bit;

          inc ( bits_sent  );
          dec ( bits_to_go );

          repeat

             if ( bits_to_go = 0 ) then
                begin
                big_buffer[ buffer_index ] := buffer;
                bits_to_go := bits_per_buffer;
                buffer := 0;
                inc ( buffer_index );
                if ( buffer_index = 512 ) then
                   begin
                   blockwrite ( bits_file, big_buffer, sizeof(big_buffer) );
                   fillchar(big_buffer, sizeof(big_buffer), 0);
                   buffer_index := 0;
                   end;
                end;

             if ( bits_to_follow > 0 ) then { must shift some bits }
                begin
                if ( bits_to_follow <= bits_to_go ) then
                   bits_to_shift := bits_to_follow
                else
                   bits_to_shift := bits_to_go;
                inc ( bits_sent,      bits_to_shift );
                dec ( bits_to_go,     bits_to_shift );
                dec ( bits_to_follow, bits_to_shift );
                buffer := buffer shr bits_to_shift;
                if ( bit ) then
                   { follow bits are zero - already done! }
                else
                   buffer := buffer or one_masks[ bits_to_shift ];
                end;

             until (bits_to_follow = 0) and (bits_to_go <> 0);

          end; { bit_plus_follow }


procedure encode_symbol ( symbol : integer );

          var range : longint;

          begin

          range := longint ( high - low ) + 1;

          { narrow the code region to that allotted to this symbol }

          high := low + ( range * cum_freq[ symbol-1 ]) div cum_freq[ 0 ] - 1;
          low  := low + ( range * cum_freq[ symbol   ]) div cum_freq[ 0 ];

          { output bits }

          while true do
                begin

                if      ( high < half ) then
                   { output 0 if in low half }
                   bit_plus_follow ( false )

                else if ( low >= half ) then
                   { output 1 and subtract offset to top if in high half }
                   begin
                   bit_plus_follow ( true );
                   dec ( low,  half );
                   dec ( high, half );
                   end

                else if ( low >= first_qtr ) and ( high < third_qtr ) then
                   { output an opposite bit later and subtract offset to }
                   { middle if in middle half                            }
                   begin
                   inc ( bits_to_follow );
                   dec ( low,  first_qtr );
                   dec ( high, first_qtr );
                   end

                else exit; { all done, so return to caller }

                { scale up code range }

                low  := low shl 1;
                high := (high shl 1) + 1

                end;

          end; { encode_symbol }

function done_encoding : longint;

         var last_chars : integer; { # of characters in last long int }

         begin

         encode_symbol ( eof_symbol );

         { output two bits that select the quarter that the current code }
         { range contains                                                }

         inc ( bits_to_follow );

         if   ( low < first_qtr ) then bit_plus_follow ( false )
         else                          bit_plus_follow ( true  );

         buffer := buffer shr bits_to_go;

         last_chars := 4 - ( bits_to_go div 8 );

         big_buffer[ buffer_index ] := buffer;

         blockwrite ( bits_file, big_buffer, (buffer_index)*4+last_chars );

         close ( bits_file );

         done_encoding := ( ( bits_sent + 7 ) div 8 ) + 1; { +1 for model }

         end; { done_encoding }


END. { arithmetic encoding implementation }